home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLEVAL.C < prev    next >
Text File  |  1985-01-01  |  8KB  |  344 lines
  1. /* xleval - xlisp evaluator */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack,*xlenv,*xlnewenv;
  7. extern NODE *s_lambda,*s_macro;
  8. extern NODE *k_optional,*k_rest,*k_aux;
  9. extern NODE *s_evalhook,*s_applyhook;
  10. extern NODE *s_unbound;
  11. extern NODE *s_stdout;
  12.  
  13. /* forward declarations */
  14. FORWARD NODE *xlxeval();
  15. FORWARD NODE *evalhook();
  16. FORWARD NODE *evform();
  17. FORWARD NODE *evsym();
  18. FORWARD NODE *evfun();
  19.  
  20. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  21. NODE *xleval(expr)
  22.   NODE *expr;
  23. {
  24.     return (s_evalhook->n_symvalue ? evalhook(expr) : xlxeval(expr));
  25. }
  26.  
  27. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  28. NODE *xlxeval(expr)
  29.   NODE *expr;
  30. {
  31.     /* evaluate null to itself */
  32.     if (expr == NULL)
  33.     return (NULL);
  34.  
  35.     /* add trace entry */
  36.     xltpush(expr);
  37.  
  38.     /* check type of value */
  39.     if (consp(expr))
  40.     expr = evform(expr);
  41.     else if (symbolp(expr))
  42.     expr = evsym(expr);
  43.  
  44.     /* remove trace entry */
  45.     xltpop();
  46.  
  47.     /* return the value */
  48.     return (expr);
  49. }
  50.  
  51. /* xlapply - apply a function to a list of arguments */
  52. NODE *xlapply(fun,args)
  53.   NODE *fun,*args;
  54. {
  55.     NODE *val;
  56.  
  57.     /* check for a null function */
  58.     if (fun == NULL)
  59.     xlfail("bad function");
  60.  
  61.     /* evaluate the function */
  62.     if (subrp(fun))
  63.     val = (*fun->n_subr)(args);
  64.     else if (consp(fun)) {
  65.     if (car(fun) != s_lambda)
  66.         xlfail("bad function type");
  67.     val = evfun(fun,args);
  68.     }
  69.     else
  70.     xlfail("bad function");
  71.  
  72.     /* return the result value */
  73.     return (val);
  74. }
  75.  
  76. /* evform - evaluate a form */
  77. LOCAL NODE *evform(expr)
  78.   NODE *expr;
  79. {
  80.     NODE *oldstk,fun,args,*val,*type;
  81.  
  82.     /* create a stack frame */
  83.     oldstk = xlsave(&fun,&args,NULL);
  84.  
  85.     /* get the function and the argument list */
  86.     fun.n_ptr = car(expr);
  87.     args.n_ptr = cdr(expr);
  88.  
  89.     /* evaluate the first expression */
  90.     if ((fun.n_ptr = xleval(fun.n_ptr)) == NULL)
  91.     xlfail("bad function");
  92.  
  93.     /* evaluate the function */
  94.     if (subrp(fun.n_ptr) || fsubrp(fun.n_ptr)) {
  95.     if (subrp(fun.n_ptr))
  96.         args.n_ptr = xlevlist(args.n_ptr);
  97.     val = (*fun.n_ptr->n_subr)(args.n_ptr);
  98.     }
  99.     else if (consp(fun.n_ptr)) {
  100.     if ((type = car(fun.n_ptr)) == s_lambda) {
  101.         args.n_ptr = xlevlist(args.n_ptr);
  102.         val = evfun(fun.n_ptr,args.n_ptr);
  103.     }
  104.     else if (type == s_macro) {
  105.         args.n_ptr = evfun(fun.n_ptr,args.n_ptr);
  106.         val = xleval(args.n_ptr);
  107.     }
  108.     else
  109.         xlfail("bad function type");
  110.     }
  111.     else if (objectp(fun.n_ptr))
  112.     val = xlsend(fun.n_ptr,args.n_ptr);
  113.     else
  114.     xlfail("bad function");
  115.  
  116.     /* restore the previous stack frame */
  117.     xlstack = oldstk;
  118.  
  119.     /* return the result value */
  120.     return (val);
  121. }
  122.  
  123. /* evalhook - call the evalhook function */
  124. LOCAL NODE *evalhook(expr)
  125.   NODE *expr;
  126. {
  127.     NODE *oldstk,*oldenv,fun,args,*val;
  128.  
  129.     /* create a new stack frame */
  130.     oldstk = xlsave(&fun,&args,NULL);
  131.  
  132.     /* get the hook function */
  133.     fun.n_ptr = s_evalhook->n_symvalue;
  134.  
  135.     /* make an argument list */
  136.     args.n_ptr = newnode(LIST);
  137.     rplaca(args.n_ptr,expr);
  138.  
  139.     /* rebind the hook functions to nil */
  140.     oldenv = xlenv;
  141.     xlsbind(s_evalhook,NULL);
  142.     xlsbind(s_applyhook,NULL);
  143.  
  144.     /* call the hook function */
  145.     val = xlapply(fun.n_ptr,args.n_ptr);
  146.  
  147.     /* unbind the symbols */
  148.     xlunbind(oldenv);
  149.  
  150.     /* restore the previous stack frame */
  151.     xlstack = oldstk;
  152.  
  153.     /* return the value */
  154.     return (val);
  155. }
  156.  
  157. /* xlevlist - evaluate a list of arguments */
  158. NODE *xlevlist(args)
  159.   NODE *args;
  160. {
  161.     NODE *oldstk,src,dst,*new,*last,*val;
  162.  
  163.     /* create a stack frame */
  164.     oldstk = xlsave(&src,&dst,NULL);
  165.  
  166.     /* initialize */
  167.     src.n_ptr = args;
  168.  
  169.     /* evaluate each argument */
  170.     for (val = NULL; src.n_ptr; src.n_ptr = cdr(src.n_ptr)) {
  171.  
  172.     /* check this entry */
  173.     if (!consp(src.n_ptr))
  174.         xlfail("bad argument list");
  175.  
  176.     /* allocate a new list entry */
  177.     new = newnode(LIST);
  178.     if (val)
  179.         rplacd(last,new);
  180.     else
  181.         val = dst.n_ptr = new;
  182.     rplaca(new,xleval(car(src.n_ptr)));
  183.     last = new;
  184.     }
  185.  
  186.     /* restore the previous stack frame */
  187.     xlstack = oldstk;
  188.  
  189.     /* return the new list */
  190.     return (val);
  191. }
  192.  
  193. /* evsym - evaluate a symbol */
  194. LOCAL NODE *evsym(sym)
  195.   NODE *sym;
  196. {
  197.     NODE *p;
  198.  
  199.     /* check for a reference to an instance variable */
  200.     if ((p = xlobsym(sym)) != NULL)
  201.     return (car(p));
  202.  
  203.     /* get the value of the variable */
  204.     while ((p = sym->n_symvalue) == s_unbound)
  205.     xlunbound(sym);
  206.  
  207.     /* return the value */
  208.     return (p);
  209. }
  210.  
  211. /* xlunbound - signal an unbound variable error */
  212. xlunbound(sym)
  213.   NODE *sym;
  214. {
  215.     xlcerror("try evaluating symbol again","unbound variable",sym);
  216. }
  217.  
  218. /* evfun - evaluate a function */
  219. LOCAL NODE *evfun(fun,args)
  220.   NODE *fun,*args;
  221. {
  222.     NODE *oldstk,*oldenv,*oldnewenv,cptr,*fargs,*val;
  223.  
  224.     /* create a stack frame */
  225.     oldstk = xlsave(&cptr,NULL);
  226.  
  227.     /* skip the function type */
  228.     if ((fun = cdr(fun)) == NULL || !consp(fun))
  229.     xlfail("bad function definition");
  230.  
  231.     /* get the formal argument list */
  232.     if ((fargs = car(fun)) && !consp(fargs))
  233.     xlfail("bad formal argument list");
  234.  
  235.     /* bind the formal parameters */
  236.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  237.     xlabind(fargs,args);
  238.     xlfixbindings();
  239.  
  240.     /* execute the code */
  241.     for (cptr.n_ptr = cdr(fun); cptr.n_ptr != NULL; )
  242.     val = xlevarg(&cptr.n_ptr);
  243.  
  244.     /* restore the environment */
  245.     xlunbind(oldenv); xlnewenv = oldnewenv;
  246.  
  247.     /* restore the previous stack frame */
  248.     xlstack = oldstk;
  249.  
  250.     /* return the result value */
  251.     return (val);
  252. }
  253.  
  254. /* xlabind - bind the arguments for a function */
  255. xlabind(fargs,aargs)
  256.   NODE *fargs,*aargs;
  257. {
  258.     NODE *arg;
  259.  
  260.     /* evaluate and bind each required argument */
  261.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  262.  
  263.     /* bind the formal variable to the argument value */
  264.     xlbind(arg,car(aargs));
  265.  
  266.     /* move the argument list pointers ahead */
  267.     fargs = cdr(fargs);
  268.     aargs = cdr(aargs);
  269.     }
  270.  
  271.     /* check for the '&optional' keyword */
  272.     if (consp(fargs) && car(fargs) == k_optional) {
  273.     fargs = cdr(fargs);
  274.  
  275.     /* bind the arguments that were supplied */
  276.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  277.  
  278.         /* bind the formal variable to the argument value */
  279.         xlbind(arg,car(aargs));
  280.  
  281.         /* move the argument list pointers ahead */
  282.         fargs = cdr(fargs);
  283.         aargs = cdr(aargs);
  284.     }
  285.  
  286.     /* bind the rest to nil */
  287.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  288.  
  289.         /* bind the formal variable to nil */
  290.         xlbind(arg,NULL);
  291.  
  292.         /* move the argument list pointer ahead */
  293.         fargs = cdr(fargs);
  294.     }
  295.     }
  296.  
  297.     /* check for the '&rest' keyword */
  298.     if (consp(fargs) && car(fargs) == k_rest) {
  299.     fargs = cdr(fargs);
  300.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  301.         xlbind(arg,aargs);
  302.     else
  303.         xlfail("symbol missing after &rest");
  304.     fargs = cdr(fargs);
  305.     aargs = NULL;
  306.     }
  307.  
  308.     /* check for the '&aux' keyword */
  309.     if (consp(fargs) && car(fargs) == k_aux)
  310.     while ((fargs = cdr(fargs)) != NULL && consp(fargs))
  311.         xlbind(car(fargs),NULL);
  312.  
  313.     /* make sure the correct number of arguments were supplied */
  314.     if (fargs != aargs)
  315.     xlfail(fargs ? "too few arguments" : "too many arguments");
  316. }
  317.  
  318. /* iskeyword - check to see if a symbol is a keyword */
  319. LOCAL int iskeyword(sym)
  320.   NODE *sym;
  321. {
  322.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  323. }
  324.  
  325. /* xlsave - save nodes on the stack */
  326. NODE *xlsave(n)
  327.   NODE *n;
  328. {
  329.     NODE **nptr,*oldstk;
  330.  
  331.     /* save the old stack pointer */
  332.     oldstk = xlstack;
  333.  
  334.     /* save each node */
  335.     for (nptr = &n; *nptr != NULL; nptr++) {
  336.     rplaca(*nptr,NULL);
  337.     rplacd(*nptr,xlstack);
  338.     xlstack = *nptr;
  339.     }
  340.  
  341.     /* return the old stack pointer */
  342.     return (oldstk);
  343. }
  344.